home *** CD-ROM | disk | FTP | other *** search
/ MACD 5 / MACD 5.bin / workbench / boot / czesc_2 / smsrc / sm / idcmp.pas < prev    next >
Pascal/Delphi Source File  |  1995-07-11  |  7KB  |  298 lines
  1. Procedure DoShell(n : pMyNode);
  2. VAR
  3.     nd : pMyNode;
  4.     
  5. begin
  6.     if n^.LSK_NewShell then begin
  7.         nd := AllocMem(sizeof(tMyNode), MEMF_CLEAR);
  8.         if nd <> NIL then begin
  9.             if n^.LSK_ShellFrom <> '' then
  10.                 nd^.LSK_Cmd[1]     := 'NewShell FROM '+n^.LSK_ShellFrom
  11.             else
  12.                 nd^.LSK_Cmd[1]     := 'NewShell';
  13.             if n^.LSK_ShellWin <> '' then
  14.                 nd^.LSK_Cmd[1] := nd^.LSK_Cmd[1]+' WINDOW '+n^.LSK_ShellWin+#0
  15.             else
  16.                 nd^.LSK_Cmd[1] := nd^.LSK_Cmd[1]+#0;
  17.             nd^.LSK_ASynch       := True;
  18.             nd^.LSK_Output       := 'NIL:';
  19.             if NOT StartCLIProgram(nd) then begin end;
  20.             FreeMem_(nd, Sizeof(tMyNode));
  21.         end;
  22.     end;
  23. end;
  24.         
  25. { IDCMP loop }
  26. Function HandleIDCMP;
  27.  
  28. Const
  29.    exitflag : Boolean  = False;
  30.    rc       : shortint = 0;
  31.    j        : Integer = 1;
  32.    Ticks    : LONG = 0;
  33.    
  34. Var 
  35.     dummy, w1mask, w2mask    : longint;
  36.     Tags     : Array[0..1] of tTagItem;
  37.   message  : pIntuiMessage;
  38.   MsgClass : LongInt;
  39.   MsgCode  : Word;
  40.   gadcode  : pGadget;
  41.   StrInfo  : pStringInfo;
  42.     found    : boolean;
  43.     node     : pMyNode;
  44.     tf       : pTextFont;
  45.     it, it2  : tIntuiText;
  46.     txt, txt2 : String;
  47.     secs : Long;
  48.     cdt : pDateTime;
  49.     ds  : pDateStamp;
  50.     tg : pTagItem;
  51.     
  52.     
  53. Procedure UpDate_RAM_Time;
  54. VAR
  55.     OK  : Boolean;
  56.     mem : LONG;
  57.     
  58. begin
  59.     if (ds <> NIL) and (cdt <> NIL) and (window2 <> NIL) then begin
  60.         ds := DateStamp(ds);
  61.         With cdt^ do
  62.             dat_Stamp   := ds^;
  63.         OK := DateToStr(cdt);
  64.         txt2 := 'Time : '+PtrToPas(@txt2[1])+#0;
  65.         mem := (AvailMem(0));
  66.         Str(mem, txt);
  67.         txt := 'Free memory : '+txt+' bytes      '#0;
  68.         PrintIText(Window2^.RPort, @it, 0, 0);
  69.     end;
  70. end;
  71.  
  72. Function DoGad(GadNode : pMyNode) : Boolean;
  73.  
  74. VAR
  75.     QuitAfter : Boolean;
  76.     
  77. begin
  78.     QuitAfter := False;
  79.     DisableWindow(TheWindow, @DummyReq, waitpointer);
  80.  
  81.     if CD.cd_Rexx then begin
  82.         if GadNode^.LSK_Quit then
  83.             SendARexxCommand(CD.cd_RexxCmd3, CD.cd_RexxPort3);
  84.         SendARexxCommand(GadNode^.LSK_RexxCmd, GadNode^.LSK_RexxPort);
  85.     end;
  86.     
  87.     if NOT CD.cd_Test Then begin
  88.         If GadNode^.LSK_Quit Then
  89.             ScreenToBack(TheScreen);
  90.         WriteLogFile(lf, GadNode, False);
  91.         if NOT StartCLIProgram(GadNode) then begin
  92.             { launch failure }
  93.             QuitAfter := false;
  94.             DisplayBeep(NIL);
  95.         end else begin
  96.             { launch success }
  97.             DoShell(GadNode);
  98.             if GadNode^.LSK_Quit then begin
  99.                 QuitAfter := true;
  100.             end else begin 
  101.                 CD.cd_Wait := 0; {disable time out}
  102.             end;
  103.         end;                                  
  104.     end else begin
  105.         { Test mode }
  106.         rc := rtEZRequestA(CSCPAR(@RememberKey, 'Gadget Selected : ' + 
  107.             GadNode^.LSK_Name+'"'),
  108.             CSCPAR(@RememberKey,'OK'),NIL,NIL,@Tags);
  109.             
  110.         If GadNode^.LSK_Quit then
  111.             QuitAfter := true
  112.         else begin
  113.             QuitAfter := False;
  114.         end
  115.     end;
  116.     EnableWindow(TheWindow, @DummyReq, WindowIDCMP);
  117.     if CD.cd_ScrT = ST_RAM then
  118.         UpDate_RAM_Time;
  119.     DoGad := QuitAfter;
  120. end;
  121.  
  122. begin
  123.  
  124.     ds := AllocVec(Sizeof(tDateStamp), MEMF_CLEAR);
  125.     cdt := AllocVec(Sizeof(tDateTime), MEMF_CLEAR);
  126.     if cdt <> NIL then begin
  127.         With cdt^ do begin
  128.             dat_Format  := 4;
  129.             dat_StrTime := @txt2[1];
  130.         end;
  131.     end;
  132.     it.FrontPen := 1;
  133.     it.BackPen := 0;
  134.     it.Drawmode := JAM2;
  135.     it.LeftEdge := 0;
  136.     it.TopEdge := 2;
  137.     it.ITextFont := @CD.cd_Font;
  138.     it.IText := @txt[1];
  139.     it.NextText := @it2;
  140.     
  141.     it2 := it;
  142.     it2.TopEdge := it2.TopEdge+CD.cd_Font.ta_YSize;
  143.     it2.IText := @txt2[1];
  144.     it2.NextText := NIL;
  145.     
  146.     Tags[0].ti_Tag  := RT_Window;
  147.     Tags[0].ti_Data := Long(TheWindow);
  148.     Tags[1].ti_Tag  := TAG_END;
  149.     
  150.     { Open font and set it as the current rastport font }
  151.      tf := OpenDiskFont(@CD.cd_SFont);
  152.     SetFont(TheWindow^.RPort, tf);
  153.     
  154.     { Set the current pen to register 1 (normally black) }
  155.     SetAPen(TheWindow^.RPort, 1);
  156.    
  157.     w1mask := BitMask(TheWindow^.UserPort^.MP_SIGBIT);
  158.     if window2 <> NIL then
  159.         w2mask := BitMask(Window2^.UserPort^.MP_SIGBIT)
  160.     else
  161.         w2mask := 0;
  162.    
  163.     { Loop until exitflag is false, ie a gadget has been pressed }
  164.     While Not exitflag Do Begin
  165.         { Wait on our port }
  166.         
  167.             
  168.         dummy    := Wait(w1mask|w2mask);
  169.         
  170.         if ((dummy and w2mask) <> 0) then begin
  171.         message  := GT_GetIMsg(Window2^.userPort);
  172.         While message <> NIL do begin
  173.             MsgClass := message^.Class;
  174.             
  175.             if MsgClass = IDCMP_IDCMPUPDATE then begin
  176.                 tg := pTagItem(message^.IAddress);
  177.                 while tg^.ti_Tag <> TAG_END do begin
  178.                     If tg^.ti_Tag = DTA_Sync then begin
  179.                         RefreshDTObjectA (dto, window2, NIL, NIL);
  180.                     end;
  181.                     tg := pTagItem(LONG(tg)+Sizeof(tTagItem));
  182.                 end;
  183.             end;
  184.                 
  185.             if MsgClass = IDCMP_REFRESHWINDOW then begin
  186.                 GT_BeginRefresh(Window2);
  187.                 GT_EndRefresh(Window2, True);
  188.             end;
  189.             GT_ReplyIMsg(message);
  190.             message  := GT_GetIMsg(Window2^.userPort);
  191.         end;
  192.         end;
  193.                 
  194.         if ((dummy and w1mask) <> 0) then begin
  195.         message  := GT_GetIMsg(TheWindow^.userPort);
  196.         while message <> NIL do begin
  197.             MsgClass := message^.Class;
  198.             MsgCode  := message^.Code;
  199.             secs := message^.Seconds;
  200.           
  201.             { only copy if it is a pointer to a gadget }
  202.             if MsgClass = IDCMP_GADGETUP then begin
  203.                 GadCode  := pGadget(message^.IAddress);
  204.                 StrInfo  := gadcode^.SpecialInfo;
  205.             end else begin 
  206.                 GadCode := NIL;
  207.                 StrInfo := NIL;
  208.             end;
  209.           
  210.       { Reply as we've copied all information required }
  211.          GT_ReplyIMsg(message);
  212.             Case MsgClass Of
  213.                 IDCMP_CLOSEWINDOW : begin
  214.                     {$IFDEF DEBUG}
  215.                         Writeln('-->IDCMP_CLOSEWINDOW');
  216.                     {$ENDIF}
  217.                     { close selected so exit }
  218.                     exitflag := true;
  219.                     rc := 10;
  220.                     WriteLogFile(lf, NIL, True);
  221.                 end;
  222.                           
  223.                 IDCMP_REFRESHWINDOW : 
  224.                 {$IFDEF DEBUG}
  225.                 Begin
  226.                     Writeln('-->IDCMP_REFRESHWINDOW');
  227.                 {$ENDIF}
  228.                     RefreshWin;
  229.                 {$IFDEF DEBUG}
  230.                 end;
  231.                 {$ENDIF}
  232.                              
  233.                 IDCMP_INTUITICKS : begin
  234.                     {$IFDEF DEBUG}
  235.                         {$IFDEF DEBUGITICKS}
  236.                             Writeln('-->IDCMP_INTUITICKS');
  237.                         {$ENDIF}
  238.                     {$ENDIF}
  239.                     inc(Ticks);
  240.                     if (Ticks >= (CD.cd_Wait*10)) and (CD.cd_Wait > 0) then begin
  241.                         exitflag := true;
  242.                         rc := 10;
  243.                     end;
  244.                     if CD.cd_Wit then
  245.                         { Scroll text along the bottom of the window }
  246.                         ScrollText(TheWindow^.RPort, sizes[S_WB_L]+5, base, 
  247.                             (TheWindow^.Width-sizes[S_WB_L]-Sizes[S_WB_R]-10), CD.cd_SFont.ta_YSize, j, 
  248.                             CD.cd_WitTxt);
  249.                     if (CD.cd_ScrT = ST_RAM) and (Odd(Ticks)) then
  250.                         UpDate_RAM_Time;
  251.                 end;
  252.                                  
  253.                 IDCMP_GADGETUP : If NOT exitflag then Begin
  254.                     {$IFDEF DEBUG}
  255.                         Writeln('-->IDCMP_GADGETUP');
  256.                     {$ENDIF}
  257.                     { launch command pointed to by the gadgets userdata and set exitflag }
  258.                     { just to be sure }
  259.                     if GadCode^.GadgetID = 1 then begin
  260.                         node := pMyNode(GadCode^.UserData);
  261.                         ExitFlag := DoGad(node); 
  262.                     end;
  263.                 end;
  264.                             
  265.                 IDCMP_VANILLAKEY : if NOT exitflag then begin
  266.                     { traverse thru list searching for a node with a LSK_Key 
  267.                         that matches the character pressed. If found launch 
  268.                         command and set loopflag }
  269.                                   
  270.                     {$IFDEF DEBUG}
  271.                         Writeln('-->IDCMP_VANILLAKEY');
  272.                     {$ENDIF}
  273.                                   
  274.                     node := pMyNode(CurrentList^.lh_Head);
  275.                     found := false;
  276.                     While (pMyNode(node^.LSK_Node.ln_Succ) <> NIL) AND (NOT Found) do begin
  277.                         if UpCase(chr(msgcode)) = node^.LSK_Key[1] then
  278.                             found := true
  279.                         else 
  280.                             node := pMyNode(node^.LSK_Node.ln_Succ);
  281.                     end;
  282.                     If found then begin           
  283.                         ExitFlag := DoGad(node);
  284.                     end else DisplayBeep(TheScreen);  
  285.                 end;
  286.             End;
  287.         message  := GT_GetIMsg(TheWindow^.userPort);
  288.         end;
  289.         end;
  290.     End;
  291.     if cdt <> NIL then 
  292.         FreeVec(cdt);
  293.     if ds  <> NIL then
  294.         FreeVec(ds);
  295.     CloseFont(tf);
  296.     HandleIdcmp := rc;
  297. End;
  298.